#lang racket
;;C-EVAL-FULL.SCM             (From May 2000, edited Feb. 12, 2005)

;;6.001 PROJECT 3 Solution: COMPLETE EXPLICIT-CONTINUATION EVALUATOR
(require r5rs)
(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define rest cdr)


(define (desugar expr)
  (cond ((quoted? expr) expr)
        ((let? expr) (desugar-let expr))
        ((let*? expr) (desugar-let* expr))
        ((and? expr) (desugar-and expr))
        ((assignment? expr)
         (make-assignment (assignment-variable expr)
                          (desugar (assignment-value expr))))
        ((definition? expr)
         (make-define (definition-variable expr)
                      (desugar (definition-value expr))))
        ((begin? expr)
         (make-begin (map desugar (begin-actions expr))))
        ((lambda? expr)
         (make-lambda (lambda-parameters expr)
                      (map desugar (lambda-body expr))))
        ((cond? expr) (desugar-cond expr))
        ((application? expr) (desugar-application expr))
        (else expr)))


;;DESUGAR-AND
;turn an and into ifs.  return false, or the last true value
(define (desugar-and expr)
  (let ((a-exprs (and-exprs expr)))
    (if (pair? a-exprs)
        (let ((first-expr (car a-exprs))
              (rest-exprs (cdr a-exprs)))
          (if (pair? rest-exprs)
              (make-if (desugar first-expr)
                       (desugar (make-and rest-exprs))
                       #f)
              (desugar first-expr)))
        #t)))

(define (and? expr) (tagged-list? expr 'and))
(define and-exprs cdr)
(define (make-and exprs) (cons 'and exprs))



;;DESUGAR-LET
(define (desugar-let expr)
  (let ((names (let-bound-variables expr))
        (values (map desugar (let-values expr)))
        (body (map desugar (let-body expr))))
    (make-application (make-lambda names body)
		      values)))

(define (let? expr) (tagged-list? expr 'let))
(define (let-bound-variables expr) (map first (second expr)))
(define (let-values expr) (map second (second expr)))
(define (let-body expr) (cddr expr)) ;differs from lecture--body may be a sequence
(define (make-let bindings body)
  (cons 'let (cons bindings body)))
(define (make-application rator rands)
  (cons rator rands))


;;DESUGAR-LET*
(define (desugar-let* expr)
  (define (top-level-let*->let lexpr)
    (let ((binds (let*-bindings lexpr))
	  (bod (let*-body lexpr)))
      (if (null? binds)
	  (make-let nil bod)
	  (make-let
	     (list (car binds))
	     (if (null? (cdr binds))
		 bod
		 (list (make-let* (cdr binds) bod)))))))
  (desugar-let (top-level-let*->let expr)))

(define (let*? expr) (tagged-list? expr 'let*))
(define (let*-bindings expr) (second expr))
(define (let*-body expr) (cddr expr))
(define (make-let* binds body)
  (cons 'let* (cons binds body)))


;;ASSIGNMENT, DEFINE, BEGIN constructors
(define (make-assignment var expr)
  (list 'set! var expr))
(define (make-define var expr)
    (list 'define var expr))
(define (make-begin seq)
  (cons 'begin seq))


;;DESUGAR-COND
;transforms a cond into nested ifs.  If you run off the end, it'll
;return nil instead of the unspecified value
(define (desugar-cond expr)
  (let ((clauses (cond-clauses expr)))
    (if (null? clauses)
        '()
        (let ((fc (first clauses)))
          (if (eq? (clause-predicate fc) 'else)
              (desugar (clause-expr fc))
               (make-if (desugar (clause-predicate fc))
                        (desugar (clause-expr fc))
                        (desugar-cond (make-cond (cdr clauses)))))))))


(define (cond? expr) (tagged-list? expr 'cond))
(define (cond-clauses expr) (cdr expr))
(define (clause-predicate clause) (car clause))
(define (clause-expr clause) (sequence->expr (cdr clause)))
(define (make-cond clauses)
  (cons 'cond clauses))
(define (sequence->expr seq)
  (if (null? (cdr seq))
      (car seq)
      (cons 'begin seq)))
(define (make-if pred conseq alt)
  (list 'if pred conseq alt))


;;DESUGAR-APPLICATION
;desugar each piece of a combination
(define (desugar-application expr)
  (map desugar expr))
;;C-EVAL
;evaluate Scheme expression EXPR in environment ENV and
;pass its value to the "continuation" procedure CONT:
(define (c-eval expr env cont)
  (cond ((self-evaluating? expr) (cont expr))
        ((variable? expr) (lookup-variable-value expr env cont))
        ((quoted? expr) (cont (text-of-quotation expr)))
        ((assignment? expr) (eval-assignment expr env cont))
        ((definition? expr) (eval-definition expr env cont))
        ((if? expr) (eval-if expr env cont))
        ((lambda? expr)
         (cont (make-procedure
                (lambda-parameters expr)
                (lambda-body expr)
                env)))
        ((begin? expr)
         (eval-sequence (begin-actions expr) env cont))
        ((or? expr) (eval-or expr env cont))
        ((application? expr)
         (c-eval (operator expr) env
                 (lambda (op)
                   (eval-args-and-apply op (operands expr) env cont))))
        (else (fatal-c-eval-error
               "Unknown expression type -- C-EVAL" expr))))


;;EVAL-SEQUENCE
;EXPRS is a non-null list of expressions.  Evaluate EXPRS in
;environment ENV and pass the value of the last one to procedure CONT:
(define (eval-sequence exprs env cont)
  (if (null? (cdr exprs))
      (c-eval (car exprs) env cont)
      (c-eval (car exprs) env
              (lambda (ignore)
                (eval-sequence (cdr exprs) env cont)))))


;;EVAL-IF
;evaluate IF expression EXPR in environment ENV and
;pass its value to procedure CONT:
(define (eval-if expr env cont)
  (let ((choose-branch-eval-and-continue
         (lambda (pred-val)
           (let ((next-branch
                  (if pred-val
                      (if-consequent expr)
                      (if-alternative expr))))
             (c-eval next-branch env cont)))))
    (c-eval
     (if-predicate expr) env choose-branch-eval-and-continue)))


;;EVAL-ASSIGNMENT
;evaluate the SET! expression EXPR in environment ENV to update
;a binding in ENV.  Pass an unspecified value to CONT:
(define (eval-assignment expr env cont)
  (c-eval (assignment-value expr) env
          (lambda (val)
            (set-variable-value!
             (assignment-variable expr) val env cont))))


;;EVAL-DEFINITION
;evaluate the DEFINE expression EXPR in environment ENV to
;update a binding in the first frame of ENV.  Pass an
;unspecified value to CONT:
(define (eval-definition expr env cont)
  (c-eval (definition-value expr) env
          (lambda (val)
            (define-variable!
              (definition-variable expr) val env cont))))

;;EVAL-OR
(define (eval-or expr env cont)
  (let ((o-exprs (or-exprs expr)))
    (if (pair? o-exprs)
        (let ((first-expr (car o-exprs))
              (rest-exprs (cdr o-exprs)))
          (c-eval first-expr env
                  (lambda (val1)
                    (if (or val1 (null? rest-exprs))
                        (cont val1)
                        (eval-or (make-or rest-exprs) env cont)))))
        (cont #f))))


;;FATAL-C-EVAL-ERROR
;display error message and return an unspecified
;value directly to the superior READ-EVAL-PRINT-LOOP
(define (fatal-c-eval-error . stuff)
  (display "FATAL-C-EVAL-ERROR: ")
  (map (lambda (item) (c-print item) (display " ")) stuff)
  *unspecified)


;;INTERPRETATION-ERROR
;display error message and restart the C-EVAL read-eval-print-loop
(define (interpretation-error . stuff)
  (display "C-EVAL INTERPETATION ERROR: ")
  (map (lambda (item) (c-print item) (display " ")) stuff)
  (newline)
  (restart-c-eval))


;;EVAL-ARGS-AND-APPLY
;evaluate RANDS in environment ENV, apply OP to the list of values
;of RANDS, and pass the result of the application to procedure CONT:
(define (eval-args-and-apply op rands env cont)
  (let ((apply-and-continue
         (lambda (arg-vals)
           (c-apply op arg-vals cont))))
    (list-of-values rands env apply-and-continue)))


;;LIST-OF-VALUES
;evaluate RANDS in environment ENV and pass the list 
;of values of RANDS to the procedure CONT:
(define (list-of-values rands env cont)
  (if (null? rands)
      (cont nil)
      (c-eval
       (car rands) env
       (lambda (arg-val)
         (list-of-values
          (cdr rands) env
          (lambda (rest-vals)
            (cont (cons arg-val rest-vals))))))))

;;C-APPLY
;apply OP to ARG-VALS and pass the result to procedure CONT:
(define (c-apply op arg-vals cont)
  (cond ((primitive-procedure? op)
         (cont (apply-primitive-procedure op arg-vals)))
        ((compound-procedure? op)
         (eval-sequence
          (procedure-body op)
          (extend-environment
           (procedure-parameters op)
           arg-vals
           (procedure-environment op))
          cont))
        ((special-procedure? op)
         (apply-special op arg-vals cont))
        (else (fatal-c-eval-error
               "Unknown procedure type -- C-APPLY" op))))


;;APPLY-PRIMITIVE-PROCEDURE
;apply procedure in underlying Scheme:
(define (apply-primitive-procedure op vals)
  (apply                                ;SCHEME'S APPLY
   (primitive-implementation op) vals))


;;APPLY-SPECIAL

(define (apply-special op vals cont)
  (let ((name (special-op-name op)))
    (cond
     ((eq? '*exit name)
      (string-append                    ;CONT IS IGNORED
       ";;C-Eval" (number->string (third op)) " EXITED"))
     ((eq? '*apply name)
      (c-apply (first vals) (second vals) cont))
     ((eq? '*eval name)
      (c-eval (desugar (car vals)) the-global-environment cont))
     ((eq? '*error name)
      (let ((temp restart-c-eval))
        (set! restart-c-eval
              (lambda optional-arg
                (if (null? optional-arg)
                    (temp)  ;same as (driver-loop)
                  ;if there is an argument, then evaluate it
                  ;and pass its value to cont
                    (c-eval (desugar (car optional-arg))
                            the-global-environment
                            cont))))
        (apply fatal-c-eval-error vals)))
     ((eq? '*call-cc name)
                                        ;package up the current continuation as a c-eval special procedure
                                        ;and pass it to the argument of call-cc
      (c-apply (car vals) (list (make-continuation-value cont)) cont))
     ((eq? '*continuation name)
      ((continuation-proc op) (car vals))) ;CONT IS IGNORED
     (else (fatal-c-eval-error
            "unknown operator -- APPLY-SPECIAL" op)))))

(define (make-continuation-value cont)
  (make-special-procedure '*continuation cont))
(define (continuation-proc continuation-value)
   (third continuation-value))


;;PROCEDURE VALUES

;COMPOUND PROCEDURE ADT
;same as in lecture (except for the tag)

(define (make-procedure parameters body env)
  (list procedure-tag parameters body env))
(define procedure-tag (list 'procedure))  ;the tag will be a unique CONS-cell
(define (compound-procedure? expr)
  (tagged-list? expr procedure-tag))
(define (procedure-parameters p) (second p))
(define (procedure-body p) (third p))
(define (procedure-environment p) (fourth p))

;C-EVAL PRIMITIVE PROCEDURE ADT
;same as in lecture (except for the tag)

(define (make-primitive-procedure scheme-proc)
  (list primitive-tag scheme-proc))
(define primitive-tag (list 'primitive))
(define (primitive-implementation proc) (second proc))
(define (primitive-procedure? proc)
  (tagged-list? proc primitive-tag))

;SPECIAL PROCEDURE ADT
(define (make-special-procedure name . maybe)
  (cons special-tag (cons name maybe)))
(define (special-op-name op)
  (second op))
(define (special-procedure? op)
  (tagged-list? op special-tag))
(define special-tag (list 'special))


;;ENVIRONMENTS

;;Same as in standard meta-circular evaluator, m-eval
;; Implement environments as a list of frames; parent environment is
;; the cdr of the list.  Each frame will be implemented as a list
;; of variables and an equal length list of corresponding values.

(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define nil (list))

(define the-empty-environment nil)

;;MAKE-FRAME
; modified from lecture to handle DOTTED PARAMETERS
(define (make-frame variables values)
  (define (iter vars reverse-vars vals reverse-vals)
    (cond
     ((null? vars)
      (cons reverse-vars reverse-vals))
     ((symbol? vars)  ;DOTTED PARAMETER
      (cons
       (cons vars reverse-vars)
       (cons vals reverse-vals)))
     (else
      (iter (cdr vars)
            (cons (car vars) reverse-vars)
            (cdr vals)
            (cons (car vals) reverse-vals)))))
  (iter variables nil values nil))

(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
  (set-car! frame (cons var (car frame)))
  (set-cdr! frame (cons val (cdr frame))))

(define (extend-environment vars vals base-env)
  (cons (make-frame vars vals) base-env))


;;LOOKUP-VARIABLE-VALUE
;lookup the value of variable VAR in environment ENV and
;pass the value to procedure CONT:
(define (lookup-variable-value var env cont)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars)) (cont (car vals)))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (interpretation-error "Unbound variable -- LOOKUP" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame) (frame-values frame)))))
  (env-loop env))


;;SET-VARIABLE-VALUE!
;find the binding of variable VAR in environment ENV and
;reset its value to VAL.  Pass an unspecified value to procedure CONT:
(define (set-variable-value! var val env cont)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (set-car! vals val)
             (cont *unspecified))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (interpretation-error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame) (frame-values frame)))))
  (env-loop env))

(define *unspecified (list 'unspecified))


;;DEFINE-VARIABLE!
;find the binding of variable VAR in the first frame of environment
;ENV, or add such a binding to the frame if there is none.  Reset
;the value in the binding to VAL, and pass an unspecified value to CONT:
(define (define-variable! var val env cont)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars)
             (add-binding-to-frame! var val frame)
             (cont (string-append
                    (symbol->string var)
                    " DEFINED!")))
            ((eq? var (car vars))
             (set-car! vals val)
             (cont (string-append
                    (symbol->string var)
                    " REDEFINED!")))
            (else (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame)
          (frame-values frame))))


;;SYNTAX
;Essentially same as for m-eval

(define (tagged-list? expr tag)
  (and (pair? expr) (eq? (car expr) tag)))

(define (self-evaluating? expr)
  (or (number? expr) (string? expr) (boolean? expr)))

(define (quoted? expr) (tagged-list? expr 'quote))
(define (text-of-quotation expr) (second expr))

(define (variable? expr) (symbol? expr))
(define (assignment? expr) (tagged-list? expr 'set!))
(define (assignment-variable expr) (second expr))
(define (assignment-value expr) (third expr))

(define (dynamic? var)
  (let ((string-name (symbol->string var)))
    (and (> (string-length string-name) 2)
         (string=? "%d-" (string-head string-name 3)))))

(define (definition? expr) (tagged-list? expr 'define))
(define (definition-variable expr)
  (let ((definiens (second expr)))
    (if (symbol? definiens)
        definiens
        (first definiens))))
(define (definition-value expr)
  (let ((definiens (second expr)))
    (if (symbol? definiens)
        (third expr)
        (make-lambda (cdr definiens)    ;formal params
                     (cddr expr)))))    ;body

(define (lambda? expr) (tagged-list? expr 'lambda))
(define (lambda-parameters lambda-expr) (second lambda-expr))
(define (lambda-body lambda-expr) (cddr lambda-expr))
(define (make-lambda parms body)
  (cons 'lambda (cons parms body)))

(define (if? expr) (tagged-list? expr 'if))
(define (if-predicate expr) (second expr)) 
(define (if-consequent expr) (third expr)) 
(define (if-alternative expr)
  (if (not (null? (cdddr expr))) (fourth expr) 'false))

(define (begin? expr) (tagged-list? expr 'begin))
   ;BEGIN-ACTIONS returns a nonnull LIST of expressions:
(define (begin-actions begin-expr) (cdr begin-expr))

(define (or? expr) (tagged-list? expr 'or))
   ;OR-EXPRS returns a nonnull LIST of expressions:
(define or-exprs cdr)
(define (make-or exprs) (cons 'or exprs))

(define (application? expr) (pair? expr))
(define (operator app) (first app))
(define (operands app) (cdr app))
(define (no-operands? rands) (null? rands))
(define (first-operand rands) (first rands))
(define (rest-operands rands) (cdr rands))


;;PRINTING

;;C-PRINT
;print a c-eval value in readable format
(define (c-print val)
  (let ((global-frame (first-frame the-global-environment)))
    (define (make-printable object)
      (cond
       ((not (pair? object)) object)
       ((eq? object global-frame)
        '*the-global-env*)
       ((compound-procedure? object)
        (list
         '*compound-proc:
         (cons '*params: (procedure-parameters object))
         (cons '*body: (procedure-body object))
         (let ((env (procedure-environment object)))
           (cons
            '*vars-in-frames:
            (map (lambda (frame)
                   (if (eq? frame global-frame)
                       '*the-global-env*
                       (car frame)))
                 env)))))
       ((eq? *unspecified object) (car object))
       ((special-procedure? object)
        (let ((name (special-op-name object)))
          (cond ((null? (cddr object)) name)
                ((null? (cdddr object))
                 (list name (make-printable (third object))))
                (else (cons name
                            (apply make-printable (cddr object)))))))
       (else
        (cons (make-printable (car object))
              (make-printable (cdr object))))))
    (pretty-print (make-printable val))))


;prevent runaway printer cycles
(define *unparser-list-depth-limit* 10)
(define *unparser-list-breadth-limit* 20)


;;INITIALIZATION AND THE READ-EVAL-PRINT LOOP

         ;the user-defined environment
(define the-global-environment 'dummy)


;;START-C-EVAL
(define restart-c-eval 'dummy)

   ;sets the-global-environment to the initial environment
(define (start-c-eval n)
  (define (create-initial-environment)
    (let* ((c-procedure?
            (lambda (x)
              (or (primitive-procedure? x)
                  (compound-procedure? x)
                  (special-procedure? x))))
           (c-pair?
            (lambda (x)
              (and (pair? x)
                   (not (c-procedure? x)))))
           (c-list?
            (lambda (x) (and (c-pair? x) (list? x))))
           (c-eval-primitive-procedure-bindings
            (map (lambda (binding)
                   (list
                    (first binding)
                    (make-primitive-procedure (second binding))))
                 (list
                  (list 'car car)
                  (list 'cdr cdr)
                  (list 'cons cons)
                  (list 'null? null?)
                  (list 'list list)
                  (list 'length length)
                  (list 'eq? eq?)
                  (list 'caar caar)
                  (list 'cadr cadr)
                  (list 'cdar cdar)
                  (list 'cddr cddr)
                  (list 'first first)
                  (list 'second second)
                  (list 'third third)
                  (list 'fourth fourth)
                  (list 'cdddr cdddr)
                  (list 'boolean? boolean?)
                  (list 'not not)
                  (list 'number? number?)
                  (list 'string? string?)
                  (list 'string-append string-append)
                  (list 'number->string number->string)
                  (list 'symbol? symbol?)
                  (list 'symbol->string symbol->string)
                  (list 'string->symbol string->symbol)
                  (list 'string=? string=?)
                  (list 'string-length string-length)
                  (list 'string-head string-head)
                  (list '> >)
                  (list '< <)
                  (list '= =)
                  (list '+ +)
                  (list '- -)
                  (list '* *)
                  (list 'read read)
                  (list 'pretty-print pretty-print)
                                        ;                     (list 'desugar desugar)    only needed to run evaluator
                                        ;                     (list 'dynamic? dynamic?)
                  (list 'procedure? c-procedure?)
                  (list 'pair? c-pair?)
                  (list 'list? c-list?)
                  (list 'set-car!
                        (lambda (l v) (set-car! l v) *unspecified))
                  (list 'set-cdr!
                        (lambda (l v) (set-cdr! l v) *unspecified))
                  (list 'newline
                        (lambda () (newline) *unspecified))
                  (list 'display
                        (lambda (stuff) (display stuff) *unspecified)))))
           (special-procedure-bindings
            (map (lambda (binding)
                   (list
                    (first binding)
                    (apply make-special-procedure (cdr  binding))))
                 (list
                  (list 'exit '*exit n)
                  (list 'apply '*apply)
                  (list 'error '*error)
                  (list 'eval '*eval)
                  (list 'call-cc '*call-cc))))
           (initial-constant-bindings
            (list
             (list 'true #t)
             (list 'false #f)
             (list 'nil (list))))
           (initial-env (extend-environment nil nil the-empty-environment))
           (initial-compound-procedure-bindings
            (list
             (list 'append (make-procedure
                            'll
                            (desugar
                             '((cond
                                ((null? ll) nil)
                                ((null? (car ll)) (apply append (cdr ll)))
                                (else
                                 (cons (caar ll)
                                       (apply append (cons (cdar ll) (cdr ll))))))))
                            initial-env))
             (list 'map (make-procedure ;this is the general version of MAP
                         '(f . ll)
                                        ;MAP1 would be enough for c-eval self-evaluation:
                         '((define (map1 f l)
                             (if (null? l)
                                 nil
                                 (cons (f (car l))
                                       (map1 f (cdr l)))))
                           (if (null? (car ll))
                               nil
                               (cons (apply f (map1 car ll))
                                     (apply map (cons f (map1 cdr ll))))))
                         initial-env))))
           (frame1 (first-frame initial-env)))
      (map (lambda (binding)
             (add-binding-to-frame! (first binding) (second binding) frame1))
           (append c-eval-primitive-procedure-bindings
                   special-procedure-bindings
                   initial-constant-bindings
                   initial-compound-procedure-bindings))
      initial-env))
  (define (driver-loop)
    (prompt-for-input (input-prompt n))
    (c-eval (desugar (read))
            the-global-environment
            (lambda (output)
              (announce-output (output-prompt n))
              (c-print output)
              (driver-loop))))
  (set! the-global-environment
        (create-initial-environment))
  (set! restart-c-eval driver-loop)
  (driver-loop))

(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))

(define (announce-output string)
  (newline) (display string))

(define (input-prompt n)
  (string-append
   ";;C-Eval" (number->string n) ">> "))

(define (output-prompt n)
  (string-append
   ";;C-Eval" (number->string n) " value: "))
(define (string-head string end)
            (substring string 0 end))

(start-c-eval 1)